home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / impshell.zip / IMPSHELL.PRO < prev    next >
Text File  |  1987-04-07  |  28KB  |  691 lines
  1. code=3500
  2. nowarnings
  3. /******************    IMP SHELL   ********************************/
  4. /*                                                                */
  5. /*                                                                */
  6. /*     THE IMP SHELL EXPERT SYSTEM DEVELOPMENT ENVIRONMENT        */
  7. /*                  VERSION 1.0                                   */
  8. /*                                                                */
  9. /*                                                                */
  10. /******************************************************************/
  11.  
  12. domains
  13.    file = descriptor
  14.    infrec = imp(string,string,string,string,string,string,string,real)
  15.    reallist = real*
  16.  
  17. database
  18.    adjustflag    
  19.    convstack(string)        /*  Used in the relnevl1 module.  */
  20.    danswer(string,real)
  21.    dbimp(string,string,string,string,string,string,string,real)
  22.    define(symbol,string)   /* Used in the relnevl1 module.  */
  23.    evidence(string,real)   
  24.    hypothesis_node(string)
  25.    imp(string,string,string,string,string,string,string,real)
  26.    infer_summary(infrec,real)
  27.    stackvalue(real)         /* Used in the relnevl1 module.   */
  28.    tdbimp(string,string,string,string,string,string,string,real)
  29.    terminal_node(string)
  30.    varvalue(symbol,real)    /*  Used in the relnevl1 module.  */
  31.  
  32. predicates
  33.    absvalue(real,real)
  34.    adjuststack
  35.    allinfer(string,real)
  36.    and_go_on
  37.    answer(string,real)
  38.    append(reallist,reallist,reallist)
  39.    cleanerx
  40.    cleanery
  41.    cleanerz
  42.    cleanit1
  43.    cleanit2
  44.    cleanit3
  45.    cleanit4
  46.    cleanit5
  47.    cleanit6
  48.    cleanit7
  49.    cleanit9
  50.    cleanit10
  51.    cleanit11
  52.    cleanit12
  53.    cleanit13
  54.    cleanit14
  55.    clearall
  56.    combine(reallist,real)
  57.    cond_multiplier(string,real)
  58.    defs_go_on
  59.    display_one_answer
  60.    displayall
  61.    edit_rs
  62.    exsys_driver   
  63.    find_multiplier(string,real,string,real)
  64.    form_go_on
  65.    form_describer(string,real)
  66.    get_name(string)
  67.    getallans
  68.    getmode1(string,string)
  69.    getmode2(string,string)
  70.    gettype1(string,string) 
  71.    gettype2(string,string)
  72.    getsense(string,string)
  73.    how_explain(string)
  74.    how_describer(string)
  75.    infer(string,real)
  76.    more_defs
  77.    make_rules
  78.    make_imps
  79.    make_defs
  80.    make_terms
  81.    make_hypos
  82.    make_simples
  83.    make_ands
  84.    make_ors
  85.    make_forms
  86.    max(real,real,real)
  87.    min(real,real,real)
  88.    or_go_on
  89.    pauser
  90.    prepare_answer
  91.    purgeit
  92.    putadjustflag 
  93.    process(integer)
  94.    pick_exsys(string)
  95.    qualifier(string,real,real)
  96.    reloadit
  97.    reply_to_input(string,string,real)
  98.    repeat
  99.    record_it(char,string,string)
  100.    seerules
  101.    seeimps
  102.    seedefs
  103.    seehypos
  104.    seeterms
  105.    showresults
  106.    shell_driver
  107.    simple_go_on
  108.    supercombine(reallist,real)
  109.    why_describer(string,string,string,string,string,string,string,real)
  110.  
  111.    
  112. /*  Borland's add-on menu module.                                 */
  113. include "menu.pro"
  114. /*  The relational expression evaluator from this book.              */
  115. include "relnevl1.pro"
  116.  
  117. clauses
  118.  
  119. /******************************************************************/
  120. /*                                                                */
  121. /*       Principal Driver Code for Whole System is Here.          */
  122. /*                                                                */
  123. /******************************************************************/
  124.    shell_driver if 
  125.       makewindow(1,112,7,"IMP -- Expert System Development Shell",
  126.          0,0,25,80),
  127.       repeat,shiftwindow(1),clearwindow,
  128.       menu(6,15,
  129.          [ "Help Information",
  130.            "Make Rules for a New Expert System",
  131.            "Inspect the Rule Set that is Loaded",
  132.            "Save the Rule Set that is Loaded",
  133.            "Load an Existing Rule Set",
  134.            "Run the Presently Loaded Expert System",
  135.            "Edit an Existing Rule Set",
  136.            "Print an Existing Rule Set",
  137.            "DOS Access",
  138.            "End this program."],CHOICE),
  139.       process(CHOICE),CHOICE=10,!.
  140.  
  141. /*   High level definition of the menu choices.                 */
  142.    process(1) if file_str("impshell.hlp",ZZ),display(ZZ),!.
  143.    process(2) if clearall,make_rules,!.
  144.    process(3) if seerules,!.
  145.    process(4) if get_name(Rulefile),save(Rulefile),!.
  146.    process(5) if clearall,pick_exsys(Rulefile),consult(Rulefile),!.
  147.    process(6) if cleanerx,cleanerz,exsys_driver,!.
  148.    process(7) if clearall,edit_rs,!.
  149.    process(8) if pick_exsys(Rulefile),concat("copy ",Rulefile,Z),
  150.       concat(Z," prn:",ZZ),system(ZZ),!.
  151.    process(9) if system(""),!.
  152.    process(10) if !.
  153. /*******************************************************************/
  154.  
  155. /*  Note, processes 1,4,5,8,9 and 10, except for a few auxilliary
  156.    predicates, are completely defined by the code you see immediately
  157.    above here.  Processes with more detailed definitions are given
  158.    below.                                                         */
  159.    
  160.  
  161. /******************************************************************/
  162. /*                                                                */
  163. /*       Menu Process Number 2                                    */
  164. /*       Collecting an Initial Set of Rules.                      */
  165. /*                                                                */
  166. /******************************************************************/
  167. /*  Section asks questions about possible rules and casts
  168.     the answers in the proper rule format.                        */  
  169.    make_rules if clearwindow,make_imps,make_defs,
  170.       make_terms,make_hypos,
  171.       clearwindow,nl,nl,
  172.       write(" To make these rules permanent, save them "),
  173.       write("to a file (see main menu)."),nl,nl,
  174.       write(" The rules can be changed, after saving,"),nl,
  175.       write("     by using the edit function (see main menu)."),
  176.       nl,pauser.
  177.   
  178.    make_terms if clearwindow,nl,
  179.       write(" DEFINING THE TERMINAL NODES IN THIS RULE SET."),
  180.       repeat,nl,nl,
  181.       write(" Enter the text that defines one terminal node: "),
  182.       nl,write(" "),readln(X),assert(terminal_node(X)),more_defs,!.
  183.  
  184.    make_hypos if clearwindow,nl,
  185.       write(" DEFINING THE HYPOTHESIS NODES IN THIS RULE SET."),
  186.       repeat,nl,nl,
  187.       write(" Enter the string that defines one hypothesis node: "),
  188.       nl,write(" "),readln(X),assert(hypothesis_node(X)),more_defs,!.
  189.   
  190.    make_imps if make_simples,make_ands, make_ors, make_forms.
  191.  
  192.    make_simples if clearwindow,simple_go_on,
  193.       repeat,clearwindow,nl,
  194.       write(" DEFINING A SIMPLE IMPLICATION RULE "),nl,nl,
  195.       write(" What is to be Concluded from this implication?  "),nl,
  196.       write(" "),readln(Z),nl,
  197.       write(" What is in the premise (state it in positive form) ?"),
  198.       nl,write(" "),readln(X),nl,
  199.       write(" Should the premise be preceded by NOT (type y/n)?  "),
  200.       write(" "),readln(XX),getsense(XX,Xsign),nl,
  201.       write(" Is the rule to be reversible or not (type r/n)?   "),
  202.       write(" "),readln(R1),nl,
  203.       write(" What is the certainty?   "),
  204.       readreal(C),
  205.       assert(imp(s,R1,Z,Xsign,X,dummy,dummy,C)),more_defs,!.
  206.    make_simples if !.
  207.      
  208.    make_ands if clearwindow,and_go_on,
  209.       repeat,clearwindow,nl,
  210.       write(" DEFINING AN AND IMPLICATION RULE "),nl,nl,
  211.       write(" What is to be Concluded from this implication?  "),
  212.       nl,write(" "),readln(Z),nl,
  213.       write(" What is the first condition in the premise?  "),nl,
  214.       write(" "),readln(X),nl,
  215.       write(" Should this condition be preceded by NOT (type y/n)?  "),
  216.       write(" "),readln(XX),getsense(XX,Xsign),nl,
  217.       write(" What is the second condition in the premise?  "),nl,
  218.       write(" "),readln(Y),nl,
  219.       write(" Should this condition be preceded by NOT (type y/n)?  "),
  220.       write(" "),readln(YY),getsense(YY,Ysign),nl,
  221.       write(" Is the rule to be reversible or not (type r/n)?   "),
  222.       write(" "),readln(R1),nl,
  223.       write(" What is the certainty?   "),
  224.       readreal(C),
  225.       assert(imp(a,R1,Z,Xsign,X,Ysign,Y,C)),more_defs,!.
  226.    make_ands if !.
  227.  
  228.    make_ors if clearwindow,or_go_on,
  229.       repeat,clearwindow,nl,
  230.       write(" DEFINING AN OR IMPLICATION RULE "),nl,nl,
  231.       write(" What is to be Concluded from this implication?  "),
  232.       nl,write(" "),readln(Z),nl,
  233.       write(" What is the first condition in the premise?  "),nl,
  234.       write(" "),readln(X),nl,
  235.       write(" Should this condition be preceded by NOT (type y/n)?  "),
  236.       write(" "),readln(XX),getsense(XX,Xsign),nl,
  237.       write(" What is the second condition in the premise?  "),nl,
  238.       write(" "),readln(Y),nl,
  239.       write(" Should this condition be preceded by NOT (type y/n)?  "),
  240.       write(" "),readln(YY),getsense(YY,Ysign),nl,
  241.       write(" Is the rule to be reversible or not (type r/n)?   "),
  242.       write(" "),readln(R1),nl,
  243.       write(" What is the certainty?   "),
  244.       readreal(C),
  245.       assert(imp(o,R1,Z,Xsign,X,Ysign,Y,C)),more_defs,!.
  246.    make_ors if !.  
  247.  
  248.    make_forms if clearwindow,form_go_on,
  249.       repeat,clearwindow,nl,
  250.       write(" DEFINING A RELATIONAL EXPRESSION RULE"),
  251.       nl,nl,write(" What is to be Concluded from this implication?  "),
  252.       nl,write(" "),readln(Z),nl,
  253.       write(" State the relational expression"),
  254.       write(" to be used in the premise?  "),nl,
  255.       write(" "),readln(X),nl,
  256.       write(" Should the expression be preceded by NOT (type y/n)?  "),
  257.       write(" "),readln(XX),getsense(XX,Xsign),nl,
  258.       write(" Is the rule to be reversible or not (type r/n)?   "),
  259.       write(" "),readln(R1),nl,
  260.       write(" What is the certainty?   "),
  261.       readreal(Ct),
  262.       assert(imp(f,R1,Z,Xsign,X,dummy,dummy,Ct)),more_defs,!.
  263.    make_forms if !.  
  264.  
  265.  
  266.    make_defs if clearwindow,defs_go_on,
  267.       repeat,clearwindow,nl,
  268.       write(" SETTING UP A GENERAL PURPOSE DEFINITION."),
  269.       nl,nl,write(" What is name of the variable being defined?  "),
  270.       nl,write(" "),readln(Z),nl,
  271.       write(" What is the expression that defines the variable?  "),
  272.       nl,write(" "),readln(ZZ),nl,
  273.       assert(define(Z,ZZ)),more_defs,!.
  274.    make_defs if !.  
  275.  
  276.  
  277.    simple_go_on if nl,write(" COLLECTING RULES"),nl,nl,
  278.       write(" Do you need simple implication rules?"),
  279.       write(" -- type y/n  "),readchar(T),T='y',!.
  280.  
  281.    and_go_on if nl,write(" COLLECTING RULES"),nl,nl,
  282.       write(" Do you need AND implication rules?"),
  283.       write(" -- type y/n  "),readchar(T),T='y',!.
  284.   
  285.    or_go_on if nl,write(" COLLECTING RULES"),nl,nl,
  286.       write(" Do you need OR implication rules?"),
  287.       write(" -- type y/n  "),readchar(T),T='y',!.
  288.  
  289.    form_go_on if nl,write(" COLLECTING RULES"),nl,nl,
  290.       write(" Do you need relational expression rules?"),
  291.       write(" -- type y/n  "),readchar(T),T='y',!.
  292.  
  293.    defs_go_on if nl,write(" COLLECTING DEFINITIONS"),nl,nl,
  294.       write(" Do you want to define any formulas?"),
  295.       write(" -- type y/n  "),readchar(T),T='y',!.
  296.         
  297.    more_defs if 
  298.       nl,write(" ************  More entries of this kind? -- type y/n.  "),
  299.       readchar(T),T='n',!.
  300.  
  301. /*  Used in setting up the negation of premises.  */
  302.    getsense("y","neg").
  303.    getsense("n","pos").
  304. /*******************************************************************/
  305.  
  306.  
  307.  
  308. /******************************************************************/
  309. /*                                                                */
  310. /*       Menu Process Number 3                                    */
  311. /*       Inspecting the Rules                                     */
  312. /*                                                                */
  313. /******************************************************************/
  314.    seerules if clearwindow,not(seeimps),not(seedefs),
  315.       not(seeterms),not(seehypos),nl,pauser.
  316.  
  317.    seeimps if imp(A,B,C,D,D1,E,F,F1),
  318.       write("imp(",A,",",B,",",C,",",D,",",D1,",",E,",",F,",",F1,")"),
  319.       nl,fail.
  320.  
  321.    seedefs if define(X,Y),write("define(",X,",",Y,")"),nl,fail.
  322.  
  323.    seeterms if terminal_node(X),write("terminal_node(",X,")."),nl,fail.
  324.  
  325.    seehypos if hypothesis_node(X),write("hypothesis_node(",X,")."),
  326.       nl,fail.
  327. /*******************************************************************/
  328.  
  329.  
  330.  
  331. /******************************************************************/
  332. /*                                                                */
  333. /*       Menu Process Number 6                                    */
  334. /*       This code actually runs an existing expert system.       */
  335. /*                                                                */
  336. /******************************************************************/
  337. /*  The driver rule for all inferencing operations.                */
  338.    exsys_driver if 
  339.       makewindow(10,7,7,"RUNNING EXPERT SYSTEM",2,5,19,65),  
  340.       getallans,           
  341.       makewindow(11,7,7,"RESULT SUMMARY",4,9,19,65),
  342.       showresults,!.
  343.  
  344.    getallans if not(prepare_answer).
  345.  
  346.    showresults if not(displayall).
  347.  
  348.    prepare_answer if answer(X,Y),fail.
  349.  
  350.    answer(X,Y) if hypothesis_node(X),allinfer(X,Y),
  351.       assert(danswer(X,Y)).
  352.  
  353.    displayall if display_one_answer,fail.
  354.     
  355.    display_one_answer if danswer(X,Y),clearwindow,
  356.       write("For this hypothesis: "),nl,write("    ",X),nl,
  357.       write("The certainty is:  ",Y),nl,nl,not(how_describer(X)).
  358. /*  End of driver for all inferencing operations.                */       
  359.  
  360.  
  361. /*    Inference Rules and Mechanisms Used by a Running System     */
  362. /*  Simple implication rules.                                     */
  363.    infer(Node1,Ct) if imp(s,Use,Node1,Sign,Node2,_,_,C1),
  364.       asserta(dbimp(s,Use,Node1,Sign,Node2,dummy,dummy,C1 )),
  365.       asserta(tdbimp(s,Use,Node1,Sign,Node2,dummy,dummy,C1 )),
  366.       allinfer(Node2,C2),qualifier(Use,C2,Qmult),
  367.       find_multiplier(Sign,Mult,dummy,0),Ct = Mult*C1*C2*Qmult,
  368.       assertz(infer_summary(
  369.          imp(s,Use,Node1,Sign,Node2,dummy,dummy,C1),Ct)),
  370.       retract(dbimp(s,Use,Node1,Sign,Node2,dummy,dummy,C1 )),
  371.       retract(tdbimp(s,Use,Node1,Sign,Node2,dummy,dummy,C1 )).
  372.  
  373. /*  Inference involving an AND implication.                      */
  374.    infer(Node1,Ct) if imp(a,Use,Node1,SignL,Node2,SignR,Node3,C1),
  375.       asserta(dbimp(a,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  376.       asserta(tdbimp(a,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  377.       allinfer(Node2,C2),allinfer(Node3,C3),
  378.       find_multiplier(SignL,MultL,SignR,MultR),
  379.       C2S = MultL*C2,C3S = MultR*C3,min(C2S,C3S,CE),
  380.       qualifier(Use,CE,Qmult),Ct = CE*C1*Qmult,
  381.       assertz(infer_summary(
  382.          imp(a,Use,Node1,SignL,Node2,SignR,Node3,C1),Ct)),
  383.       retract(dbimp(a,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  384.       retract(tdbimp(a,Use,Node1,SignL,Node2,SignR,Node3,C1 )).
  385.  
  386. /*  Inference involving an OR implication.                       */
  387.    infer(Node1,Ct) if imp(o,Use,Node1,SignL,Node2,SignR,Node3,C1),
  388.       asserta(dbimp(o,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  389.       asserta(tdbimp(o,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  390.       allinfer(Node2,C2),allinfer(Node3,C3),
  391.       find_multiplier(SignL,MultL,SignR,MultR),
  392.       C2S = MultL*C2,C3S = MultR*C3,max(C2S,C3S,CE),
  393.       qualifier(Use,CE,Qmult),Ct = CE*C1*Qmult,
  394.       assertz(infer_summary(
  395.          imp(o,Use,Node1,SignL,Node2,SignR,Node3,C1),Ct)),
  396.       retract(dbimp(o,Use,Node1,SignL,Node2,SignR,Node3,C1 )),
  397.       retract(tdbimp(o,Use,Node1,SignL,Node2,SignR,Node3,C1 )).
  398.  
  399. /**  Inference Processing for relational expressions (formulas).  */
  400.    infer(Node1,Ct) if imp(f,Use,Node1,Csign,Cond,dummy,dummy,C),
  401.       asserta(dbimp(f,Use,Node1,Csign,Cond,dummy,dummy,C )),
  402.       asserta(tdbimp(f,Use,Node1,Csign,Cond,dummy,dummy,C )),
  403.       clearwindow,
  404.       write("Need to ask some questions to evaluate a formula."),
  405.       nl,nl,cleanerz,expr_eval(Cond,TF),cond_multiplier(Csign,Cmult),
  406.       XXX=TF*Cmult,qualifier(Use,XXX,Qmult),Ct = XXX*C*Qmult,
  407.       assertz(infer_summary(
  408.          imp(f,Use,Node1,Csign,Cond,dummy,dummy,C),Ct)),
  409.       form_describer(Node1,Ct),
  410.       retract(dbimp(f,Use,Node1,Csign,Cond,dummy,dummy,C )),
  411.       retract(tdbimp(f,Use,Node1,Csign,Cond,dummy,dummy,C )).
  412.  
  413. /**  Inference Processing for terminal nodes.                    */
  414.    infer(Node1,Ct) if terminal_node(Node1),evidence(Node1,Ct),!.
  415.  
  416.    infer(Node1,Ct) if terminal_node(Node1),repeat,nl,clearwindow,
  417.       write("For this condition:"),nl,nl,write("    ",Node1),nl,nl,
  418.       write("Type y(yes), n(no), or w(why),"),nl,
  419.       write(" or give a certainty (-1.0 to +1.0)."),nl,
  420.       nl,readln(Reply),reply_to_input(Node1,Reply,Ct),!.
  421.  
  422. /*  Used to arbitrate reversibility of rules.                    */
  423.    qualifier(Use,C,Qmult) if Use="r",Qmult=1,!.
  424.    qualifier(Use,C,Qmult) if Use="n",C >= 0,Qmult=1,!.
  425.    qualifier(Use,C,Qmult) if Use="n",C < 0,Qmult=0,!.
  426.  
  427. /*  Used to provide for negation of the premise of a rule when
  428.      that premise is a relational expression (i.e. a formula.)   */  
  429.    cond_multiplier( pos,1 ).
  430.    cond_multiplier( neg,-1).
  431.       
  432. /*  Used to provide sign changes where needed for negation.       */   
  433. /*  This is used for simple implication.                          */
  434.    find_multiplier(pos,1,dummy,0) .
  435.    find_multiplier(neg,-1,dummy,0) .
  436. /*  This is used for AND and OR                                   */
  437.    find_multiplier(pos, 1,pos, 1) .
  438.    find_multiplier(pos, 1,neg,-1) .
  439.    find_multiplier(neg,-1,pos, 1) .
  440.    find_multiplier(neg,-1,neg,-1) .
  441.  
  442. /*  Collects the results of all applicable rules at a node.       */     
  443.    allinfer(Node,Ct) if findall(C1,infer(Node,C1),Ctlist),
  444.       supercombine(Ctlist,Ct).           
  445.       
  446. /*  Implements updating with a two at a time combination rule.    */      
  447.    supercombine([Ct],Ct) if !.
  448.    supercombine([C1,C2],Ct) if combine([C1,C2],Ct),!.
  449.    supercombine([C1,C2|T],Ct) if combine([C1,C2],C3),
  450.       append([C3],T,TL),supercombine(TL,Ct),!.
  451.                    
  452. /* This predicate combines evidence from two
  453.    rules when they each apply to a single conclusion.
  454.    First argument is a list of certainties. Second is
  455.    what they all resolve too.                                      */
  456.  
  457.    combine([-1,1],0.0).
  458.    combine([1,-1],0.0).
  459.  
  460.    combine([C1,C2],Ct) if C1 >= 0, C2 >= 0,
  461.       Ct = C1 + C2 - C1*C2.
  462.    combine([C1,C2],Ct) if C1 < 0, C2 < 0,
  463.       Ct = C1 + C2 + C1*C2.
  464.    combine([C1,C2],Ct) if C1 < 0, C2 >= 0,
  465.       absvalue(C1,Z1), absvalue(C2,Z2),min(Z1,Z2,Z3),
  466.       Ct = (C1 + C2)/(1.0 - Z3).
  467.    combine([C1,C2],Ct) if C2 < 0, C1 >= 0,
  468.       absvalue(C1,Z1), absvalue(C2,Z2),min(Z1,Z2,Z3),
  469.       Ct = (C1 + C2)/(1.0 - Z3).
  470.  
  471.    
  472. /**     Administers Terminal Node input and Why Questions.        */
  473. /*  Note, all data for system comes in at terminal nodes. 
  474.     Possible input is a certainty figure, or yes, or no, or why.  */
  475.    reply_to_input(Node,Reply,Ct) if not(isname(Reply)),
  476.       adjuststack,str_real(Reply,Ct),asserta(evidence(Node,Ct)),!.
  477.  
  478.    reply_to_input(Node,Reply,Ct) if isname(Reply),Reply = "y",
  479.       adjuststack,Ct=1.0,asserta(evidence(Node,Ct)),!.
  480.  
  481.    reply_to_input(Node,Reply,Ct) if isname(Reply),Reply = "n",
  482.       adjuststack,Ct=-1.0,asserta(evidence(Node,Ct)),!.
  483.  
  484.    reply_to_input(_,Reply,_) if isname(Reply),Reply = "w",nl,
  485.       dbimp(U,V,R,S,S1,X,Y,Y1),
  486.       why_describer(U,V,R,S,S1,X,Y,Y1),
  487.       retract(dbimp(U,V,R,S,S1,X,Y,Y1)),
  488.       putadjustflag,
  489.       pauser,!,fail.
  490.  
  491.    reply_to_input(_,Reply,_) if
  492.       isname(Reply),Reply = "c",adjuststack,!.
  493.  
  494.  
  495. /**** Administers Special why explanations from an inference that
  496.       involves the a relational expression in the premise.  *****/
  497.    form_describer(Node,Ct) if       
  498.       repeat,nl,nl,
  499.       write("To see the reason for these questions, "),
  500.       write("or for this processing."),
  501.       nl,write("type w(why).  Otherwise type c(continue)."),
  502.       nl,readln(Reply),reply_to_input(Node,Reply,Ct),!.
  503.  
  504.  
  505. /*  Answers why questions for and/or rules.                       */
  506.    why_describer(U,U1,V,R,S,X,Y,Z) if clearwindow,nl,
  507.       U <> "s",U <> "f",gettype2(U,UU), 
  508.       write("I am trying to use an inference rule of the "),nl,
  509.       write(UU),write(" type, to support the conclusion: "),nl,
  510.       write("    ",V),nl,write("Premise 1 is: ",S),nl,getmode1(R,RR),
  511.       write("    This premise will be used ",RR),nl,
  512.       write("Premise 2 is: ",Y),nl,getmode1(X,XX),
  513.       write("    This premise will be used ",XX),nl,
  514.       write("The certainty of the implication is: ",Z),nl,!.
  515.  
  516. /*  Answers why questions for simple implications.                 */
  517.    why_describer("s",V1,V,R,S,X,Y,Z) if clearwindow,nl,
  518.       write("I am trying to use an inference rule of the "),nl,
  519.       write("SIMPLE type, to support the conclusion: "),nl,
  520.       write("    ",V),nl,write("Premise 1 is: ",S),nl,getmode1(R,RR),
  521.       write("    This premise will be used ",RR),nl,
  522.       write("The certainty of the implication is: ",Z),nl,!.
  523.  
  524. /*  Answers why questions for relational expression rules.        */
  525.    why_describer("f",V1,V,R,S,X,Y,Z) if clearwindow,nl,
  526.       write("I am trying to use an inference rule of the "),
  527.       nl,write("RELATIONAL EXPRESSION type, "),
  528.       write("to support the conclusion: "),nl,
  529.       write("    ",V),nl,write("Premise 1 is:  ",S),nl,getmode1(R,RR),
  530.       write("    This premise will be used ",RR),nl,
  531.       write("The certainty of the implication is: ",Z),nl,!.
  532.      
  533. /*  Used to expand terse rule format for user friendlyness.       */      
  534.    gettype1("a"," an and implication").
  535.    gettype1("o"," an or implication").
  536.    gettype1("s"," a simple implication").
  537.    gettype1("f"," a relational expression implication").
  538.  
  539.    gettype2("a","AND").
  540.    gettype2("o","OR").
  541.   
  542.    getmode1("pos","just as you see it.").
  543.    getmode1("neg","prefaced by not.").    
  544.  
  545.    getmode2("pos"," ").
  546.    getmode2("neg"," NOT ").
  547.    getmode2("dummy"," ").
  548.  
  549. /*  Restores stack as was before why questions.                  */
  550.    adjuststack if adjustflag,retract(adjustflag),purgeit,reloadit,!.
  551.    adjuststack.
  552.  
  553.    purgeit  if retract(dbimp(_,_,_,_,_,_,_,_)),fail.
  554.    purgeit.
  555.  
  556.    reloadit if tdbimp(X,Y,Z,R,R1,S,V,V1),
  557.       assertz(dbimp(X,Y,Z,R,R1,S,V,V1)),fail.
  558.    reloadit.
  559.  
  560. /* Makes sure just one flag is on stack after it's called.        */
  561. /*  Flag is used to show when why stack needs restoration.        */
  562.    putadjustflag if not(adjustflag),asserta(adjustflag).
  563.    putadjustflag.
  564. /*   End of Administration of Terminal Questions and Why's        */
  565.  
  566.  
  567. /*  Administers how explanations.                                 */
  568.    how_describer(Node) if hypothesis_node(Node),repeat,nl,
  569.       write("Type h(how) conclusion, or c(continue)."),
  570.       nl,readln(Reply),nl,how_explain(Reply),!.
  571.     
  572.    how_explain(X) if X = "c".
  573.  
  574.  /*  Used for all reasoned conclusions.                           */
  575.    how_explain(Reply) if 
  576.       fronttoken(Reply,_,X1),fronttoken(X1,X2,Y),concat(X2,Y,X),
  577.       infer_summary(imp(_,_,X,_,_,_,_,_),_),clearwindow,!,
  578.       write("The rule(s) that bear upon this conclusion are: "),nl,nl,
  579.       infer_summary(imp(A,A1,X,R,S,C,D,E),F),
  580.       write("Concluded:  ",X),nl,gettype1(A,Z),write(" from",Z),nl,
  581.       getmode2(R,RR),write(" premise 1 was:",RR,"(",S,")"),nl,
  582.       getmode2(C,CC),write(" premise 2 was:",CC,"(",D,")"),nl,
  583.       write("The certainty from use of this rule alone was: ",F), 
  584.       nl,nl,fail.
  585.             
  586. /*  To explain terminal facts.                                    */            
  587.    how_explain(Reply) if 
  588.       fronttoken(Reply,_,X1),fronttoken(X1,X2,Y),concat(X2,Y,X),
  589.       terminal_node(X),evidence(X,C),
  590.       write("You told me that: "),nl,write("   ",X),nl,
  591.       write("with a certainty of: ",C),nl,fail.
  592. /******************************************************************/
  593. /*******  End of Inference Rules and Mechanisms Section     *******/
  594.  
  595.  
  596.  
  597. /******************************************************************/
  598. /*                                                                */
  599. /*       Menu Process Number 7                                    */
  600. /*       Editing an Existing Rule Set                             */
  601. /*                                                                */
  602. /******************************************************************/
  603.    edit_rs if
  604.       pick_exsys(Filename),file_str(Filename,Inputstring),
  605.       edit(Inputstring,Outputstring),clearwindow,
  606.       write("Save this Rule Set? (type y/n) "),
  607.       readchar(Ans),record_it(Ans,Outputstring,Filename).
  608.  
  609.    record_it('y',Data,Filename) if
  610.       openwrite(descriptor,Filename),writedevice(descriptor),
  611.       write(Data),closefile(descriptor),clearall,consult(Filename).
  612.  
  613.    record_it('n',_,_).
  614. /******************************************************************/
  615.  
  616.  
  617.  
  618. /******************************************************************/
  619. /*                                                                */
  620. /*       Various Auxilliary Predicates                            */
  621. /*                                                                */
  622. /******************************************************************/
  623. /*  Low level predicates used in multiple places in the system. ***/
  624.    get_name(Name) if makewindow(10,7,7,"GET FILE NAME",10,10,10,60),
  625.       nl,write("State a DOS filename for this Rule Set."),
  626.       nl,write("Do not use a file extension."),
  627.       nl,readln(Z),concat(Z,".rul",Name),removewindow,!.
  628.   
  629.    pauser if nl,nl,
  630.         write(" **********  Hit any key to continue."),readchar(T).
  631.  
  632.    pick_exsys(Rules) if 
  633.       makewindow(10,7,7,"PICK A RULE SET",10,10,10,60),
  634.       dir("//","*.rul",Rules),removewindow.
  635.  
  636. /*  Predicates for initialization and reinitialization.           */
  637. /*  Used to clean up  results of one run with a given rule set.   */
  638.    cleanerx if not(cleanit1),not(cleanit2),not(cleanit3),
  639.       not(cleanit4),not(cleanit5),not(cleanit10),not(cleanit13).
  640.       
  641.       cleanit1 if retract(evidence(_,_)),fail.
  642.       cleanit2 if retract(dbimp(_,_,_,_,_,_,_,_)),fail.
  643.       cleanit3 if retract(tdbimp(_,_,_,_,_,_,_,_)),fail.
  644.       cleanit4 if retract(infer_summary(_,_)),fail.
  645.       cleanit5 if retract(adjustflag),fail.           
  646.       cleanit10 if retract(danswer(_,_)),fail.
  647.       cleanit13 if retract(varvalue(_,_)),fail.
  648.  
  649. /*  Used for completely changing a rule set.                      */ 
  650.    cleanery if not(cleanit6),not(cleanit7),
  651.       not(cleanit9),not(cleanit14).
  652.  
  653.       cleanit6 if retract(imp(_,_,_,_,_,_,_,_)),fail.
  654.       cleanit7 if retract(terminal_node(_)),fail.
  655.       cleanit9 if retract(hypothesis_node(_)),fail.
  656.       cleanit14 if retract(define(_,_)),fail.
  657.  
  658. /*  Used to clean up after one use of the expression evaluator.   */
  659.    cleanerz if not(cleanit11),not(cleanit12).
  660.  
  661.       cleanit11 if retract(convstack(_)),fail.
  662.       cleanit12 if retract(stackvalue(_)),fail.
  663.  
  664. /*  Used to reinitialize -- cleans everything.                    */
  665.    clearall if cleanerx,cleanery,cleanerz.
  666. /****End of low level predicates used in multiple places.*********/
  667.  
  668.  
  669. /* General Purpose Predicates normally kept in a library module. */ 
  670. /* Standard minimum and maximum predicates.                      */
  671.    max(C1,C2,C2 ) if C2 >= C1,!.
  672.    max(C1,C2,C1) if C2 < C1,!.
  673.    min(C1,C2,C2) if C2 <= C1,!.
  674.    min(C1,C2,C1) if C2 > C1,!.
  675.  
  676. /*  New absolute value expression.                               */
  677.    absvalue(X,Y) if X = 0,Y = 0, !.
  678.    absvalue(X,Y) if X > 0, Y = X, !.
  679.    absvalue(X,Y) if X < 0, Y = -X, !.
  680.  
  681.    repeat.
  682.    repeat if repeat.
  683.  
  684.    append([],List,List).
  685.    append([X|L1],List2,[X|L3]) if append(L1,List2,L3).
  686. /******************************************************************/
  687.  
  688.  
  689. goal
  690.    shell_driver.
  691.